home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / UNIXTOOL / GNU / TILEFORTH / TILE / TILE~ / !Tile / test / blocks < prev    next >
Text File  |  1992-04-19  |  883b  |  60 lines
  1. .( Loading Blocks test...) cr
  2.  
  3. #include <tile$lib>.blocks
  4.  
  5. locals blocks
  6.  
  7. .( 1: Define a code block for "nip") cr 
  8.  
  9. block[ swap drop ]; constant nip ( -- block)
  10.  
  11. 1 2 nip call . cr
  12.  
  13.  
  14. .( 2: Define a code block in a colon definition and call it) cr
  15.  
  16. : foo ( x -- int)
  17.   block[ ( x -- int)
  18.     5 + 3 *
  19.   ]; call
  20. ;
  21.  
  22. 6 foo . cr
  23.  
  24.  
  25. .( 3: Make a colon definition return a code block depending on parameter) cr
  26.  
  27. : fie ( flag -- block)
  28.   if block[ 5 + ]; else block[ 8 + ]; then
  29. ;
  30.  
  31. 5 true fie call . cr
  32.  
  33.  
  34. .( 4: Show that blocks can return blocks as values) cr
  35.  
  36. 5 false
  37. block[ ( flag -- block)
  38.   if block[ 5 + ]; else block[ 8 + ]; then
  39. ];
  40. call
  41. call . cr
  42.  
  43.  
  44. .( 5: Define a generalized factorial function block) cr
  45.  
  46. block[ { x y z } 
  47.   x 0>
  48.   if x 1- y z y call x *
  49.   else z call then
  50. ]; constant general-fac
  51.  
  52. : fac ( n -- n!)
  53.   general-fac block[ 1 ]; general-fac call
  54. ;
  55.  
  56. 5 fac . cr
  57.  
  58. forth only
  59.  
  60.